﻿(*                  FnSharp              

   Base class library extensions and frameworks aimed 
   specifically at improving F# developers lives!

   Written by: Huw Simpson
   License: Microsoft Public License (Ms-PL) 
   Available at: http://fnsharp.codeplex.com

*)
namespace FnSharp.Fundamental.CommandLine
    open System
    open System.IO
    open System.Reflection
    open Microsoft.FSharp.Reflection
    open FParsec
    open FParsec.Primitives
    open FParsec.CharParsers
    open Newtonsoft.Json
    open Newtonsoft.Json.Serialization

    /// This module contains functions pertaining to command line argument handling.
    [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
    module Arguments =  
        module private Helper =
            let write (x:obj) =
                use sw = new System.IO.StringWriter ()
                use writer = new JsonTextWriter (sw)
                let serializer = new JsonSerializer ()
                serializer.Converters.Add (new Json.OptionTypeConverter ())
                serializer.Serialize (writer, x)
                sw.ToString ()

            let writeList items =
                items 
                |> String.join ","
                |> fun s -> "[" + s + "]"

            let writeMap items =
                items 
                |> String.join ","
                |> fun s -> "{" + s + "}"

            let writeTuple items =
                items
                |> Seq.mapi (fun i s -> sprintf "'Item%i' : %s" i s)
                |> String.join ";"
                |> fun s -> "{" + s + "}"
                
        [<AutoOpen>]
        module private TypeHelper =
            let inline (|Generic|NonGeneric|) (typ:Type) =
                if typ.IsGenericType then 
                    let typDef = typ.GetGenericTypeDefinition ()
                    Generic (typDef, typ.GetGenericArguments () |> Array.toList)
                else NonGeneric (typ)

            let inline (|Option|_|) typ =
                match typ with
                | Generic (t, [a]) when t = typedefof<option<_>> -> Some (a)
                | _ -> None

        [<AutoOpen>]
        module private ParserPervasives =
            let ws = spaces
            let ws1 = spaces1
            let str s = pstring s
            let pstrlit:Parser<String,obj> =
                let normalCharSnippet = manySatisfy (fun c -> c <> '\\' && c <> '"')
                let escapedChar = pstring "\\" >>. (anyOf "\\nrt\"" |>> function
                                                                        | 'n' -> "\n"
                                                                        | 'r' -> "\r"
                                                                        | 't' -> "\t"
                                                                        | c   -> string c)

                between (str "\"") (str "\"") (stringsSepBy normalCharSnippet escapedChar)

            let pbool = 
                (stringReturn "true"  true)  <|> (stringReturn "True"  true) <|>
                (stringReturn "false" false) <|> (stringReturn "False" false)

        [<AutoOpen>]
        module internal IntermediateType =
            type SimpleType = 
                | Int8'  
                | UInt8' 
                | Int16' 
                | UInt16'
                | Int32' 
                | UInt32'
                | Int64' 
                | UInt64'
                | Single'
                | Double'
                | String'
                | Bool'

                static member map = function
                    | NonGeneric t when t = typeof<int8>   -> Int8'
                    | NonGeneric t when t = typeof<uint8>  -> UInt8'
                    | NonGeneric t when t = typeof<int16>  -> Int16'
                    | NonGeneric t when t = typeof<uint16> -> UInt16'
                    | NonGeneric t when t = typeof<int32>  -> Int32'
                    | NonGeneric t when t = typeof<uint32> -> UInt32'
                    | NonGeneric t when t = typeof<int64>  -> Int64'
                    | NonGeneric t when t = typeof<uint64> -> UInt64'
                    | NonGeneric t when t = typeof<single> -> Single'
                    | NonGeneric t when t = typeof<double> -> Double'
                    | NonGeneric t when t = typeof<string> -> String'
                    | NonGeneric t when t = typeof<bool>   -> Bool'
                    | _ -> failwith "Unsupported type"

                static member parse = function
                    | Int8'    -> pint8   |>> Helper.write
                    | UInt8'   -> puint8  |>> Helper.write
                    | Int16'   -> pint16  |>> Helper.write
                    | UInt16'  -> puint16 |>> Helper.write
                    | Int32'   -> pint32  |>> Helper.write
                    | UInt32'  -> puint32 |>> Helper.write
                    | Int64'   -> pint64  |>> Helper.write
                    | UInt64'  -> puint64 |>> Helper.write
                    | Single'  -> pfloat  |>> Helper.write
                    | Double'  -> pfloat  |>> Helper.write
                    | String'  -> pstrlit |>> Helper.write
                    | Bool'    -> pbool   |>> Helper.write

                static member usage = function
                    | Int8'    -> sprintf "%i..%i" SByte.MinValue Byte.MaxValue
                    | UInt8'   -> sprintf "%i..%i" Byte.MinValue Byte.MaxValue
                    | Int16'   -> sprintf "%i..%i" Int16.MinValue Int16.MaxValue
                    | UInt16'  -> sprintf "%i..%i" UInt16.MinValue UInt16.MaxValue
                    | Int32'   -> sprintf "%i..%i" Int32.MinValue Int32.MaxValue
                    | UInt32'  -> sprintf "%i..%i" UInt32.MinValue Int32.MaxValue
                    | Int64'   -> sprintf "%i..%i" Int64.MinValue Int64.MaxValue
                    | UInt64'  -> sprintf "%i..%i" UInt64.MinValue UInt64.MaxValue
                    | Single'  -> sprintf "%f..%f" Single.MinValue Single.MaxValue
                    | Double'  -> sprintf "%f..%f" Double.MinValue Double.MaxValue
                    | String'  -> "\"Double quoted text\" or 'single quoted text'"
                    | Bool'    -> "true / false"           

                static member asString typ (value:obj) =
                    match typ with
                    | Int8'    -> sprintf "%i" (value :?> int8)
                    | UInt8'   -> sprintf "%i" (value :?> uint8)
                    | Int16'   -> sprintf "%i" (value :?> int16)
                    | UInt16'  -> sprintf "%i" (value :?> uint16)
                    | Int32'   -> sprintf "%i" (value :?> int32)
                    | UInt32'  -> sprintf "%i" (value :?> uint32)
                    | Int64'   -> sprintf "%i" (value :?> int64)
                    | UInt64'  -> sprintf "%i" (value :?> uint64)
                    | Single'  -> sprintf "%f" (value :?> Single)
                    | Double'  -> sprintf "%f" (value :?> Double)
                    | Bool'    -> sprintf "%b" (value :?> bool)
                    | String'  -> sprintf "%s" (value :?> string)
            
            type ComplexType =
                | Simple of SimpleType
                | List' of ComplexType
                | Map' of SimpleType * ComplexType
                | Option' of ComplexType
                | Tuple1' of ComplexType
                | Tuple2' of ComplexType * ComplexType
                | Tuple3' of ComplexType * ComplexType * ComplexType
                | Tuple4' of ComplexType * ComplexType * ComplexType * ComplexType
                | Tuple5' of ComplexType * ComplexType * ComplexType * ComplexType * ComplexType
                | Tuple6' of ComplexType * ComplexType * ComplexType * ComplexType * ComplexType * ComplexType
                | Tuple7' of ComplexType * ComplexType * ComplexType * ComplexType * ComplexType * ComplexType * ComplexType

                static member map = function
                    | NonGeneric t when t.IsArray -> List' (ComplexType.map (t.GetElementType ()))
                    | NonGeneric t -> Simple (SimpleType.map (t))
                    | Generic (t, [a]) when t = typedefof<List<_>> -> List' (ComplexType.map (a))
                    | Generic (t, [a]) when t = typedefof<System.Collections.Generic.List<_>> -> List' (ComplexType.map (a))
                    | Generic (t, [a]) when t = typedefof<option<_>> -> Option' (ComplexType.map (a))
                    | Generic (t, [a; b]) when t = typedefof<Map<_,_>> -> Map' (SimpleType.map (a), ComplexType.map (b))
                    | Generic (t, [a; b]) when t = typedefof<System.Collections.Generic.Dictionary<_,_>> -> Map' (SimpleType.map (a), ComplexType.map (b))
                    | Generic (t, [a])              when FSharpType.IsTuple (t) -> Tuple1' (ComplexType.map (a))
                    | Generic (t, [a;b])            when FSharpType.IsTuple (t) -> Tuple2' (ComplexType.map (a), ComplexType.map (b))
                    | Generic (t, [a;b;c])          when FSharpType.IsTuple (t) -> Tuple3' (ComplexType.map (a), ComplexType.map (b), ComplexType.map (c))
                    | Generic (t, [a;b;c;d])        when FSharpType.IsTuple (t) -> Tuple4' (ComplexType.map (a), ComplexType.map (b), ComplexType.map (c), ComplexType.map (d))
                    | Generic (t, [a;b;c;d;e])      when FSharpType.IsTuple (t) -> Tuple5' (ComplexType.map (a), ComplexType.map (b), ComplexType.map (c), ComplexType.map (d), ComplexType.map (e))
                    | Generic (t, [a;b;c;d;e;f])    when FSharpType.IsTuple (t) -> Tuple6' (ComplexType.map (a), ComplexType.map (b), ComplexType.map (c), ComplexType.map (d), ComplexType.map (e), ComplexType.map (f))
                    | Generic (t, [a;b;c;d;e;f;g])  when FSharpType.IsTuple (t) -> Tuple7' (ComplexType.map (a), ComplexType.map (b), ComplexType.map (c), ComplexType.map (d), ComplexType.map (e), ComplexType.map (f), ComplexType.map (g))
                    | Generic _ -> failwith "Unsupported type"
                 
                static member parse = function
                    | Simple t1     -> SimpleType.parse t1 
                    | List'  t1     -> between (str "[") (str "]") (sepBy (ws >>. ComplexType.parse (t1) .>> ws) (str "," <|> str ";")) |>> Helper.writeList
                    | Map' (t1,t2)   -> 
                        let parseKeyValue t1 t2 =
                            parse { let! key = SimpleType.parse (t1) |>> Helper.write
                                    let! _ = ws >>. (str "->" <|> str ":" <|> str "=") .>> ws
                                    let! value = ComplexType.parse (t2) |>> Helper.write
                                    return key + ":" + value }  
                        between (str "{") (str "}") (sepBy (ws >>. parseKeyValue t1 t2 .>> ws) (str "," <|> str ";")) |>> Helper.writeMap
                    | Tuple1' (t1)  -> 
                        ComplexType.parse (t1) |>> fun v -> Helper.writeTuple [v] 
                    | Tuple2' (t1,t2)  -> 
                        parse { let! item1 = ComplexType.parse (t1) .>> ws1
                                let! item2 = ComplexType.parse (t2)
                                return Helper.writeTuple [item1;item2] }
                    | Tuple3' (t1,t2,t3)  -> 
                        parse { let! item1 = ComplexType.parse (t1) .>> ws1
                                let! item2 = ComplexType.parse (t2) .>> ws1
                                let! item3 = ComplexType.parse (t3)
                                return Helper.writeTuple [item1;item2;item3] }
                    | Tuple4' (t1,t2,t3,t4)  -> 
                        parse { let! item1 = ComplexType.parse (t1) .>> ws1
                                let! item2 = ComplexType.parse (t2) .>> ws1
                                let! item3 = ComplexType.parse (t3) .>> ws1
                                let! item4 = ComplexType.parse (t4)
                                return Helper.writeTuple [item1;item2;item3;item4] }
                    | Tuple5' (t1,t2,t3,t4,t5)  -> 
                        parse { let! item1 = ComplexType.parse (t1) .>> ws1
                                let! item2 = ComplexType.parse (t2) .>> ws1
                                let! item3 = ComplexType.parse (t3) .>> ws1
                                let! item4 = ComplexType.parse (t4) .>> ws1
                                let! item5 = ComplexType.parse (t5)
                                return Helper.writeTuple [item1;item2;item3;item4;item5] }
                    | Tuple6' (t1,t2,t3,t4,t5,t6)  -> 
                        parse { let! item1 = ComplexType.parse (t1) .>> ws1
                                let! item2 = ComplexType.parse (t2) .>> ws1
                                let! item3 = ComplexType.parse (t3) .>> ws1
                                let! item4 = ComplexType.parse (t4) .>> ws1
                                let! item5 = ComplexType.parse (t5) .>> ws1
                                let! item6 = ComplexType.parse (t6)
                                return Helper.writeTuple [item1;item2;item3;item4;item5;item6] }
                    | Tuple7' (t1,t2,t3,t4,t5,t6,t7)  -> 
                        parse { let! item1 = ComplexType.parse (t1) .>> ws1
                                let! item2 = ComplexType.parse (t2) .>> ws1
                                let! item3 = ComplexType.parse (t3) .>> ws1
                                let! item4 = ComplexType.parse (t4) .>> ws1
                                let! item5 = ComplexType.parse (t5) .>> ws1
                                let! item6 = ComplexType.parse (t6) .>> ws1
                                let! item7 = ComplexType.parse (t7)
                                return Helper.writeTuple [item1;item2;item3;item4;item5;item6;item7] }
                    | Option' t1  -> 
                        ((ComplexType.parse (t1) |>> Some) <|> (str "_" |>> fun _ -> None)) |>> Helper.write

                static member usage = function
                    | Simple  (t1) -> SimpleType.usage t1
                    | List'   (t1) -> sprintf "[%s,..]" (ComplexType.usage t1)
                    | Map' (t1,t2) -> sprintf "{%s=%s,..}" (SimpleType.usage t1) (ComplexType.usage t2)
                    | Option' (t1) -> sprintf "_ / %s" (ComplexType.usage t1)     
                    | Tuple1' (t1) ->                   sprintf "%s"                    (ComplexType.usage t1)
                    | Tuple2' (t1,t2) ->                sprintf "%s %s"                 (ComplexType.usage t1) (ComplexType.usage t2)
                    | Tuple3' (t1,t2,t3) ->             sprintf "%s %s %s"              (ComplexType.usage t1) (ComplexType.usage t2) (ComplexType.usage t3)
                    | Tuple4' (t1,t2,t3,t4) ->          sprintf "%s %s %s %s"           (ComplexType.usage t1) (ComplexType.usage t2) (ComplexType.usage t3) (ComplexType.usage t4)
                    | Tuple5' (t1,t2,t3,t4,t5) ->       sprintf "%s %s %s %s %s"        (ComplexType.usage t1) (ComplexType.usage t2) (ComplexType.usage t3) (ComplexType.usage t4) (ComplexType.usage t5)
                    | Tuple6' (t1,t2,t3,t4,t5,t6) ->    sprintf "%s %s %s %s %s %s"     (ComplexType.usage t1) (ComplexType.usage t2) (ComplexType.usage t3) (ComplexType.usage t4) (ComplexType.usage t5) (ComplexType.usage t6)
                    | Tuple7' (t1,t2,t3,t4,t5,t6,t7) -> sprintf "%s %s %s %s %s %s %s"  (ComplexType.usage t1) (ComplexType.usage t2) (ComplexType.usage t3) (ComplexType.usage t4) (ComplexType.usage t5) (ComplexType.usage t6) (ComplexType.usage t7)
        
                static member asString typ (value:obj) =
                    match typ with
                    | Simple t   -> value |> SimpleType.asString (t)
                    | List'  t   -> 
                        seq { for item in value :?> System.Collections.IEnumerable do
                                yield item |> ComplexType.asString (t) }
                        |> Seq.toArray
                        |> String.join ","
                        |> fun s -> "[" + s + "]"
                    | Map' (a,b) ->
                        seq { for kvp in value :?> System.Collections.IEnumerable do
                                let tkvp = kvp.GetType ()
                                let key = tkvp.GetProperty("Key").GetValue(kvp, null)
                                let value = tkvp.GetProperty("Value").GetValue(kvp, null) 
                                yield key,value } 
                        |> Seq.map (fun (k,v) -> sprintf "%s->%s" (k |> SimpleType.asString (a)) (v |> ComplexType.asString (b)))
                        |> String.join ","
                        |> fun s -> "{" + s + "}"
                    | Tuple1' (t1) -> 
                        FSharpValue.GetTupleFields (value) |> Array.zip [|t1|]
                        |> Array.map (fun (t,v) -> v |> ComplexType.asString (t))
                        |> String.join " "
                    | Tuple2' (t1,t2) -> 
                        FSharpValue.GetTupleFields (value) |> Array.zip [|t1;t2|]
                        |> Array.map (fun (t,v) -> v |> ComplexType.asString (t))
                        |> String.join " "
                    | Tuple3' (t1,t2,t3) -> 
                        FSharpValue.GetTupleFields (value) |> Array.zip [|t1;t2;t3|]
                        |> Array.map (fun (t,v) -> v |> ComplexType.asString (t))
                        |> String.join " "
                    | Tuple4' (t1,t2,t3,t4) -> 
                        FSharpValue.GetTupleFields (value) |> Array.zip [|t1;t2;t3;t4|]
                        |> Array.map (fun (t,v) -> v |> ComplexType.asString (t))
                        |> String.join " "
                    | Tuple5' (t1,t2,t3,t4,t5) -> 
                        FSharpValue.GetTupleFields (value) |> Array.zip [|t1;t2;t3;t4;t5|]
                        |> Array.map (fun (t,v) -> v |> ComplexType.asString (t))
                        |> String.join " "
                    | Tuple6' (t1,t2,t3,t4,t5,t6) -> 
                        FSharpValue.GetTupleFields (value) |> Array.zip [|t1;t2;t3;t4;t5;t6|]
                        |> Array.map (fun (t,v) -> v |> ComplexType.asString (t))
                        |> String.join " "
                    | Tuple7' (t1,t2,t3,t4,t5,t6,t7) -> 
                        FSharpValue.GetTupleFields (value) |> Array.zip [|t1;t2;t3;t4;t5;t6;t7|]
                        |> Array.map (fun (t,v) -> v |> ComplexType.asString (t))
                        |> String.join " "
                    | Option' t when value = null -> "_"
                    | Option' t -> value.GetType().GetProperty("Value").GetValue(value, null) |> ComplexType.asString (t)    

        [<AutoOpen>]
        module private ParserPervasives2 =
            let parseArg name (typ:Type) sep = sep >>. ((str "-" <|> str "/") >>. str name >>. ws1 >>. (typ |> ComplexType.map |> ComplexType.parse))
            let tryParseArg name (typ:Type) sep = opt (attempt (sep >>. (str "-" <|> str "/") >>. str name) >>. ws1 >>. (typ |> ComplexType.map |> ComplexType.parse))

            let rec combine sep (props:(string * PropertyInfo) list) =
                match props with
                | [] -> failwith "This shouldn't happen!"
                | [name,prop] -> 
                    match prop.PropertyType with
                    | Option (t) -> tryParseArg name prop.PropertyType sep |>> fun x -> Seq.singleton (name,x)
                    | t -> parseArg name prop.PropertyType sep |>> fun x -> Seq.singleton (name, Some (x))
                | (name,prop)::tl -> 
                    match prop.PropertyType with
                    | Option (t) -> tryParseArg name prop.PropertyType sep |>> fun x -> Seq.singleton (name,x)
                    | t -> parseArg name prop.PropertyType sep |>> fun x -> Seq.singleton (name, Some (x))
                    .>>. (tl |> combine (ws1)) |>> fun (x,s) -> Seq.append x s

            let read<'T> input =
                let typ = typeof<'T>
                let props = (if FSharpType.IsRecord (typ) then FSharpType.GetRecordFields (typ) else typ.GetProperties ()) |> Array.map (fun p -> p.Name,p)

                let pp = ws >>. (props |> Array.toList |> combine (preturn (()))) .>> ws

                match runParserOnString pp null "input" input with
                | Success (res,x,y) -> 
                    try
                        let values = res |> dict
                        let ser = new JsonSerializer ()
                        ser.Converters.Add (new Json.OptionTypeConverter ())

                        props
                        |> Array.map (fun (name,prop) ->
                            match values.TryGetValue (name) |> Option.ofBool2 with
                            | Some (Some (v)) -> 
                                use reader = new StringReader (v)
                                ser.Deserialize (reader, prop.PropertyType)
                            | _ when prop.PropertyType.IsValueType -> Activator.CreateInstance (prop.PropertyType)
                            | _ -> null
                            |> fun v -> prop,v)
                        |> Choice1Of2                   
                    with e -> Choice2Of2 (e.Message)
                | Failure (message,_,_) -> Choice2Of2 (message)

        /// Create argument usage text from a type.
        let usage<'T> =
            let typ = typeof<'T>
            let props = if FSharpType.IsRecord (typ) then FSharpType.GetRecordFields (typ) else typ.GetProperties ()

            props
            |> Array.map (fun prop -> sprintf "-%s %s" (prop.Name) (prop.PropertyType |> ComplexType.map |> ComplexType.usage))
            |> String.join "\r\n"
            |> fun s -> sprintf "Command Usage:\r\n%s" s                

        /// Map arguments to a F# record instance.
        let mapToRecord<'T> input =
            if FSharpType.IsRecord (typeof<'T>) = false then failwith "Only F# record types are supported by this function!"

            match read<'T> input with
            | Choice1Of2 values -> 
                Choice1Of2 (FSharpValue.MakeRecord (typeof<'T>, values |> Array.map (snd)) :?> 'T)
            | Choice2Of2 message -> Choice2Of2 (message, usage<'T>)

        /// Map arguments to a CLI class instance.
        let mapToClass<'T when 'T : (new : unit -> 'T)> input =
            match read<'T> input with
            | Choice1Of2 values -> 
                let instance = new 'T ()
                values |> Array.iter (fun (prop,value) -> prop.SetValue (instance, value, null))
                Choice1Of2 (instance)
            | Choice2Of2 message -> Choice2Of2 (message, usage<'T>)

        /// Map a type instance to arguments.
        let mapToArgs<'T> (instance:'T) =
            let typ = typeof<'T>
            let props = if FSharpType.IsRecord (typ) then FSharpType.GetRecordFields (typ) else typ.GetProperties ()

            props
            |> Array.choose (fun prop -> 
                prop.PropertyType 
                |> ComplexType.map 
                |> fun t -> prop.GetValue (instance, null) |> ComplexType.asString (t)
                |> fun s -> if s <> "_" then Some (sprintf "-%s %s" prop.Name s) else None)
            |> String.join " "